home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / comp0_89.lha / Feel / Boot / Compiler / test.em‾ < prev    next >
Encoding:
Text File  |  1993-07-23  |  5.2 KB  |  299 lines
  1. ;; Eulisp Module
  2. ;; Author: pete broadbery
  3. ;; File: test.em
  4. ;; Date: 3/sep/1991
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;
  9.  
  10. (defmodule test 
  11.   (   
  12.    ;;eulisp0
  13.    )
  14.   ()
  15.  
  16.   (defun foo ()
  17.     "test" 7)
  18.  
  19.   '(defun bar ()
  20.     "wibble")
  21.  
  22. )
  23.  
  24.   (defconstant abcd "")
  25.   
  26.   (defconstant t1 (mk-finder))
  27.   (export t1)
  28.  
  29.  
  30.   (defconstant xx-setter 1);; (compile-inline 1 (slot-ref 4)))
  31.   (compile-declare xx-setter setter-function t)
  32.    
  33.   (defconstant xx-setter-setter (compile-inline 2 (set-slot 4)))
  34.   (compile-add-callback xx-setter-setter setter-setter-function xx)
  35.   
  36.   (xx-setter-setter xx-setter xx-setter-setter)
  37.  
  38.   ((xx-setter xx-setter) xx-setter-setter xx-setter-setter)
  39.  
  40.   (export xx-setter xx-setter-setter)
  41.  
  42.   ;;(defun xx () 1)
  43.   ;;(defun yy (a) a)
  44.   ;;((xx-setter xx-setter) xx yy)
  45.  
  46.   ;;(export xx yy)
  47.  
  48.  
  49.   (deflocal xx nil)
  50.   (deflocal yy nil)
  51.   (deflocal zz nil)
  52.  
  53.   (defun reset ()
  54.     (setq xx nil)
  55.     (setq yy nil)
  56.     (setq zz nil)
  57.     xx)
  58.  
  59.   (defun foo (x)
  60.     (labels ((countdown (n)
  61.             (if (= n 0) 0 (progn (print n) (countdown (- n 1))))))
  62.         (lambda ()
  63.           (countdown x))))
  64.   
  65.   (defun rewrite-inline-lambda (lambda-term)
  66.     (labels ((rewrite-args (args values)
  67.                (print (list args values))
  68.                (cond ((null args) nil)
  69.                  ((atom args) 
  70.                   (list (list args (cons 'list values))))
  71.                  (t (cons (list (car args) (car values))
  72.                       (rewrite-args (cdr args) (cdr values)))))))
  73.       (lambda (tran args)
  74.     (print `(let ,(rewrite-args (car lambda-term) args)
  75.           ,@(cdr lambda-term))))))
  76.  
  77.   (defun test2 (x)
  78.     (print "before")
  79.     (labels ((xx (n)
  80.          (if (= n 0) 1
  81.            (xx (- n 1)))))
  82.         (let ((aa (xx x)))
  83.           (print aa)
  84.           aa)))
  85.          
  86.   (defun i (x)
  87.     x)
  88.  
  89.   (defun d (x)
  90.     nil)
  91.  
  92.   (defun a (x)
  93.     (i x))
  94.  
  95.   (defun acons (x y)
  96.     (cons x y))
  97.  
  98.   (defun test-if (x) 
  99.     (if x x 0))
  100.  
  101.   (defun test-not-if (x)
  102.     (if (not x) x 0))
  103.  
  104. ;; ok
  105.   (defun l (x)
  106.     ((lambda (y) 
  107.        y)
  108.      (+ x 1)))
  109.  
  110.   (defun fact (x)
  111.     (if (< x 1) 1 
  112.       (* x (fact (- x 1)))))
  113.  
  114.   (defun test (a)
  115.     (if (zerop a)
  116.     (+ a 3)
  117.       (- a 1)))
  118.  
  119.   (defun mk-conser (x)
  120.     (lambda (a) (cons a x)))
  121.   
  122.   (defun g-test (x)
  123.     (zerop x))
  124.  
  125.   (defun gc-test (x)
  126.     (GC)
  127.     1 2 x)
  128.   
  129.   (defun gc-test2 (x)
  130.     (if (gc-test x) 1 0))
  131.   ;;(GC)
  132.   (defun mk-counter-1 (n)
  133.     (let ((v n))
  134.       (lambda ()
  135.         ((lambda (a)
  136.            (setq v (+ v 1))
  137.            a)
  138.          v))))
  139.  
  140.   (defun nary-0 n
  141.     n)
  142.   
  143.   (defun nary-1 (n . m)
  144.     m)
  145.  
  146.   (deflocal it ())
  147.  
  148.   (defun ack (n)
  149.     (cond ((= n 0)
  150.        (print (it)))
  151.       ((= n 1)
  152.        (print (it 1)))
  153.       ((= n 2)
  154.        (print (it 1 2)))
  155.       ((= n 3)
  156.        (print (it 1 2 3)))
  157.       ((= n 4)
  158.        (print (it 1 2 3 4)))
  159.       (t "Whups")))
  160.  
  161.  
  162.    
  163.   (defun set-it (x)
  164.     (setq it x))
  165.  
  166.  
  167.   (defun set-test (a)
  168.    (car a))
  169.  
  170.   (defun set-test-setter (a b) 
  171.       ((setter car) a b))
  172.   
  173.     ((setter setter) set-test set-test-setter)
  174.    (export set-test)
  175.  
  176.   ;; more tests...
  177.   (defun bar (a b)
  178.     (let ((c (- b a)))
  179.       (cons b
  180.         (lambda (x) (+ c x)))))
  181.  
  182.   (defun ffib (x) (if (< x 2) 1 (+ (ffib (- x 1)) (ffib (- x 2)))))
  183.  
  184. '  (defun fib (x) 
  185.     (if (binary-lt x 2) 
  186.     1
  187.         (binary-plus (fib (binary-difference x 1)) 
  188.              (fib (binary-difference x 2)))))
  189.  
  190.   (defun a-mapcar (f x)
  191.     (if (null x)
  192.     nil
  193.       (cons (f (car x)) 
  194.         (a-mapcar f (cdr x)))))
  195.  
  196.   (defun afold (f l v)
  197.     (if (null l) v
  198.       (afold f (cdr l) (f (car l) v))))
  199.  
  200.   ;; import/export test
  201.   ;;(print "...")
  202.   ;;(flush (standard-output-stream))
  203.   (defconstant x (mk-finder))
  204.   (deflocal y (mk-finder))
  205.   
  206.   (export x y)
  207.  
  208.   (defun xxx (a) (mapcdr append a))
  209.  
  210.   ;; From CLTL
  211.  
  212.   (defun ipow (n k)
  213.     (labels ((e0 (x k a)
  214.          (cond ((zerop k) a)
  215.                ((evenp k) 
  216.             (e1 (* x x) (/ k 2) a))
  217.                (t (e0 (* x x) (/ k 2) (* x a)))))
  218.          (e1 (x k a)
  219.          (cond ((evenp k)
  220.             (e1 (* x x) (/ k 2) a))
  221.                (t (e0 (* x x) (/ k 2) (* x a))))))
  222.        (e0 n k 1)))
  223.  
  224.   (defun messify (x n)
  225.     (labels ((mess-aux (l r)
  226.                (cond ((null l) r)
  227.                  (t (mess-aux (cdr l)
  228.                       (cons (mapcar (lambda (b)
  229.                               (cons b n))
  230.                             (car l))
  231.                         r))))))
  232.         (mess-aux x nil)))
  233.  
  234.   ;; possibly the worst reverse in the world
  235.  (defun rev (l)
  236.    (cond  ((null l) l)
  237.       ((null (cdr l)) l)
  238.       ((null (cdr (cdr l)))
  239.        (swap l))
  240.       (t ((lambda (a1)
  241.         (cons (car a1)
  242.               (rev (cons (car l)
  243.                  (rev (cdr a1))))))
  244.           (rev (cdr l))))))
  245.  
  246.  
  247.   (defun swap (l) (cons (car (cdr l)) (cons (car l) (cdr (cdr l)))))
  248.  
  249.   (defun myappend-1 (a b)
  250.     (cond ((null a) b)
  251.       (t (cons (car a) 
  252.            (myappend-1 (cdr a) b)))))
  253.   
  254.   (defun myappend (a b)
  255.     (if (null a) b
  256.       (let ((lst (cons (car a) nil)))
  257.     (labels ((app-aux (l end)
  258.               (if (null l)
  259.                   end
  260.                 (let ((newpair (cons (car l) nil)))
  261.                   ((setter cdr) end newpair)
  262.                   (app-aux (cdr l) newpair)))))
  263.         ((setter cdr) (app-aux (cdr a) lst) b)
  264.         lst))))
  265.  
  266.   (defun repeat (f n)
  267.     (if (= n 0) nil
  268.       (progn (f) (repeat f (- n 1)))))
  269.  
  270.   (defun time (f)
  271.     (let ((xx (cpu-time)))
  272.       (f)
  273.       (- (cpu-time) xx)))
  274.  
  275.   (defun testxx ()
  276.     (let ((a (open "test.em" 'input t)))
  277.       (read a)
  278.       (close a)
  279.       (testxx)))
  280.  
  281. )
  282.  
  283. (i 0)
  284. (a 0)
  285. (acons 0 1)
  286. (ffib 21)
  287. (rev '(0 1 2 3))
  288. (test-if 1)
  289. (l 2)
  290. (fact 3)
  291. ;; also tests generic-lookup
  292. (afold + '(0 1 2.2 3) 0)
  293. (ipow 2 4)
  294. (ipow 2 5)
  295. (ipow 2 7)
  296. (rev '(0 1 2 3 4 5 6 7 8 9 0 a))
  297. (gc-test2 1)
  298. (gc-test2 nil)
  299.